home *** CD-ROM | disk | FTP | other *** search
/ Shareware Overload Trio 2 / Shareware Overload Trio Volume 2 (Chestnut CD-ROM).ISO / dir40 / pc37042.zip / CBL / TESTCIO.ALC < prev    next >
Text File  |  1987-11-20  |  8KB  |  330 lines
  1.     TITLE 'TESTCIO - PC/370 TEST COBOL SUBROUTINE I/O'
  2. *
  3. * AUTHOR.    Don Higgins.
  4. * DATE.      11/13/87. (Copied and modified from PRINTDOC.ALC)
  5. * REMARKS.   PC/370 COBOL SUBROUTINE TO READ FILE NAME PASSED FROM
  6. *            COBOL and print it with page control.
  7. *
  8. * COPYRIGHT. None.  This is a public domain program.
  9. *
  10. * MAINTENANCE.
  11. *
  12. * 11/20/87 ADD SYNERROR CALL TO DISPLAY ANY I/O ERRORS AND EXIT
  13. *          RELOCATE ROUTINE REQUIRED TO CONVERT DCB AND EXTERNAL
  14. *          ADDRESS CONSTANTS TO V=R.  CLEAR R15 RETURN CODE.
  15. * INPUT
  16. *
  17. *  1.  CALL 'TESTCIO' USING FILE-NAME.
  18. *
  19. *      FILE-NAME = MS-DOS DRIVE\PATH\FILENAME WITH TRAILING BLANKS.
  20. *
  21. * OUTPUT
  22. *
  23. *  1.  File will be printed on the standard printer device with
  24. *      page control added via TITLE, EJECT, and SPACE statements as
  25. *      defined in standard OS/VS assembler.
  26. *
  27. TESTCIO  CSECT
  28.     STM   R14,R12,12(R13)
  29.     LR    R10,R15
  30.     USING TESTCIO,R10
  31.     L     R1,0(R1)
  32.     MVC   DSNUT1,0(R1) MOVE FILE NAME TO WORK AREA
  33.     LA    R2,=C'PC/370 TESTCIO FILE PRINT SUBROUTINE$'
  34.     SVC   WTO
  35.     LA    R2,=C' $'
  36.     SVC   WTO
  37.     BAL   R14,RELOCATE ADJUST DCB ADDRESSES TO ABS. ADDR.
  38.     BAL   R14,GETPARM
  39.     LTR   R15,R15
  40.     BNZ   EOJ
  41.     BAL   R12,OPENFILE
  42.     LTR   R15,R15
  43.     BNZ   EOJ
  44.     LA    R1,ASCTITLE
  45.     LA    R2,L'ASCTITLE+L'ASCEJECT+L'ASCSPACE
  46.     SVC   EBCASC
  47.     LA    R2,=C'ENTER P FOR PRINTER OUTPUT OR ANY KEY FOR CONSOLE$'
  48.     SVC   WTO
  49.     SVC   READKEY
  50.     STC   R0,OPTION
  51. MAINLOOP EQU   *
  52.     BAL   R12,GETREC
  53.     LTR   R15,R15         TEST FOR END OF FILE
  54.     BNZ   ENDFILE
  55.     BAL   R14,SCAN
  56.     LTR   R15,R15         TEST FOR COMMAND AND SKIP PRINTING IT
  57.     BNZ   MAINLOOP
  58.     AP    LINE,=P'1'
  59.     CP    LINE,MAXLINE
  60.     BNH   NEXTLINE
  61.     BAL   R11,NEWPAGE
  62. NEXTLINE EQU   *
  63.     LA    R0,RECORD
  64.     BAL   R12,PUTREC
  65.     B     MAINLOOP
  66. ENDFILE  EQU   *
  67.     BAL   R12,CLOSEFIL
  68. EOJ      EQU   *
  69.     LM    R14,R12,12(R13)
  70.     XR    R15,R15
  71.     BR    R14
  72.     TITLE  'GETPARM - MOVE PARM TO DCB'
  73. GETPARM  EQU   *
  74.     LA    R1,DSNUT1
  75.     LA    R2,L'DSNUT1
  76. FNDBLK   EQU   *
  77.     CLI   0(R1),C' '  FIND FIRST BLANK
  78.     BE    HITBLK
  79.     LA    R1,1(R1)
  80.     BCT   R2,FNDBLK
  81.     LA    R2,=C'NO BLANK FOUND AFTER FILENAME$'
  82.     SVC   WTO
  83.     LA    R15,16
  84.     BR    R14
  85. HITBLK   EQU   *
  86.     MVI   0(R1),0     PLACE TRAILING NULL FOR OPEN
  87.     SR    R15,R15
  88.     BR    R14
  89.     TITLE 'SCAN FOR TITLE, EJECT, AND SPACE COMMANDS'
  90. SCAN     EQU   *
  91.     CLI   RECORD,ASCBLK
  92.     BE    SCANOP
  93.     CLI   RECORD,ASCTAB
  94.     BNE   SCANEXIT        EXIT IF FIRST CHAR. NOT BLANK OR TAB
  95. SCANOP   EQU   *
  96.     LA    R4,RECORD+1
  97. SKIPBLK  EQU   *
  98.     CLI   0(R4),ASCLF
  99.     BE    SCANEXIT
  100.     CLI   0(R4),ASCBLK
  101.     LA    R4,1(R4)
  102.     BE    SKIPBLK
  103.     BCTR  R4,0
  104.     CLC   0(5,R4),ASCTITLE
  105.     BE    TITLE
  106.     CLC   0(5,R4),ASCEJECT
  107.     BE    EJECT
  108.     CLC   0(5,R4),ASCSPACE
  109.     BE    SPACE
  110. SCANEXIT EQU   *
  111.     SR    R15,R15
  112.     BR    R14
  113. TITLE    EQU   *
  114.     LA    R4,5(R4)
  115. FINDQ1   EQU   *
  116.     CLI   0(R4),ASCBLK
  117.     BL    SCANEXIT     IGNORE TITLE IF FIRST QUOTE NOT FOUND
  118.     CLI   0(R4),ASCQ
  119.     LA    R4,1(R4)
  120.     BNE   FINDQ1
  121.     LA    R3,TITLEMSG
  122.     LA    R5,TITLEMSG+L'TITLEMSG
  123. FINDQ2   EQU   *
  124.     CLI   0(R4),ASCBLK
  125.     BL    SETTITLE     TRUNCATE IF SECOND QUOTE NOT FOUND
  126.     CLI   0(R4),ASCQ
  127.     BE    SETTITLE
  128.     CLR   R3,R5
  129.     BNL   SETTITLE     TRUNCATE IF TOO LONG
  130.     MVC   0(1,R3),0(R4)  COPY TITLE
  131.     LA    R3,1(R3)
  132.     LA    R4,1(R4)
  133.     B     FINDQ2
  134. SETTITLE EQU   *
  135.     CLR   R3,R5
  136.     BNL   EJECT
  137.     MVI   0(R3),ASCBLK    PAD WITH BLANKS
  138.     LA    R3,1(R3)
  139.     B     SETTITLE
  140. EJECT    EQU   *
  141.     BAL   R11,NEWPAGE
  142.     LA    R15,1
  143.     BR    R14
  144. SPACE    EQU   *
  145.     LA    R0,SPACEMSG
  146.     BAL   R12,PUTREC
  147.     LA    R0,SPACEMSG
  148.     BAL   R12,PUTREC
  149.     AP    LINE,=P'2'
  150.     LA    R15,1
  151.     BR    R14
  152.     TITLE 'NEWPAGE - PRINT HEADING'
  153. NEWPAGE  EQU   *
  154.     AP    PAGE,=P'1'
  155.     ZAP   LINE,=P'0'
  156.     MVC   DPAGE,MASK
  157.     ED    DPAGE,PAGE
  158.     MVC   PAGEMSG,PAGEWORK
  159.     LA    R1,PAGEMSG
  160.     LA    R2,L'PAGEMSG
  161.     SVC   EBCASC
  162.     LA    R0,HEADING
  163.     BAL   R12,PUTREC
  164.     MVI   HEADCC,ASCFF   FORCE FORM FEED AFTER FIRST PAGE
  165.     LA    R0,SPACEMSG
  166.     BAL   R12,PUTREC     SKIP SPACE AFTER TITLE
  167.     BR    R11
  168.     TITLE 'OPEN/CLOSE FILE ROUTINES'
  169. *
  170. * NOTE SYNAD EXIT WILL CALL SYNERROR TO FORMAT ERROR AND EXIT TO R12
  171. *
  172. OPENFILE EQU   *
  173.     LA    R2,SYSUT1
  174.     SVC   OPEN
  175.     BR    R12
  176. CLOSEFIL EQU   *
  177.     LA    R2,SYSUT1
  178.     SVC   CLOSE
  179.     BR    R12
  180.     TITLE 'GETREC - GET NEXT TEXT RECORD OR SET EOF'
  181. GETREC   EQU   *
  182.     LA    R2,SYSUT1
  183.     LA    R1,RECORD
  184.     SVC   GET
  185.     SR    R15,R15
  186.     BR    R12
  187. EOFRTN   EQU   *
  188.     LA    R15,1
  189.     BR    R12
  190. SYNRTN   EQU   *
  191.     L     R15,ASYNERR
  192.     BALR  R14,R15
  193.     LA    R15,16
  194.     BR    R12
  195.     TITLE 'PUTREC - PUT RECORD TO STD. PRINT DEVICE'
  196. PUTREC   EQU   *
  197.     LR    R4,R0
  198. PUTLOOP  EQU   *
  199.     IC    R2,0(R4)
  200.     CLI   0(R4),ASCTAB
  201.     LA    R3,1
  202.     BNE   PUTCHAR
  203.     LA    R3,9
  204.     LA    R2,ASCBLK
  205. PUTCHAR  EQU   *
  206.     SVC   CONSOLEC       PRINT ON CONSOLE
  207.     CLI   OPTION,ASCP
  208.     BE    ISUSVC
  209.     CLI   OPTION,ASCPL
  210.     BE    ISUSVC
  211.     B     PUTSKPP
  212. ISUSVC   SVC   PRINTC         PRINT ON STD. OUTPUT DEVICE ALSO
  213. PUTSKPP  EQU   *
  214.     BCT   R3,PUTCHAR
  215.     CLI   0(R4),ASCLF
  216.     LA    R4,1(R4)
  217.     BNE   PUTLOOP
  218. PUTEXIT  EQU   *
  219.     SR    R15,R15
  220.     BR    R12
  221. RELOCATE EQU   *              CONVERT DCB ADDRESSES TO ABSOLUTE ADDR.
  222.     CLI   RESET,TRUE     ONLY RELOCATE ONCE
  223.     BER   R14
  224.     MVI   RESET,TRUE
  225.     LR    R1,R10
  226.     SH    R1,=AL2(X'200')    R1 = ORIGIN USED BY L370 (BIN+X'10')
  227.     LA    R2,SYSUT1
  228.     USING IHADCB,R2
  229.     LR    R0,R1
  230.     A     R0,ASYNERR         R0 = ABS. ADDR. OF SYNERROR ROUTINE
  231.     ST    R0,ASYNERR
  232.     LR    R0,R1
  233.     A     R0,DCBDSN          R0 = ABS. ADDR. OF DSN
  234.     ST    R0,DCBDSN
  235.     LR    R0,R1
  236.     A     R0,SYNAD
  237.     ST    R0,SYNAD
  238.     LR    R0,R1
  239.     A     R0,EODAD
  240.     ST    R0,EODAD
  241.     LR    R0,R1
  242.     A     R0,RCD
  243.     ST    R0,RCD
  244.     DROP  R2
  245.     BR    R14
  246.     TITLE 'DATA SECTION'
  247.     LTORG
  248. *
  249. * REGISTER USAGE
  250. *
  251. R0       EQU   0 SVC RETURN CODE
  252. R1       EQU   1 SVC ARGUMENT
  253. R2       EQU   2 SVC ARGUMENT (DCB ADDRESS, DMA, MSG, ETC.)
  254. R3       EQU   3 POINTER FOR MOVING TITLE
  255. R4       EQU   4 OUTPUT BYTE PTR FOR PUTREC
  256. R5       EQU   5 END OF TITLE AREA
  257. R10      EQU   10 BASE
  258. R11      EQU   11 LINK FOR NEWPAGE
  259. R12      EQU   12 LINK FOR GETREC AND PUTREC
  260. R13      EQU   13 SAVE
  261. R14      EQU   14 LINK FROM MAINLINE TO ROUTINES
  262. R15      EQU   15 RETURN CODE FROM ROUTINES
  263. *
  264. * PC/370 SVC'S
  265. *
  266. EXIT     EQU   0
  267. OPEN     EQU   1
  268. CLOSE    EQU   2
  269. GET      EQU   5
  270. PUT      EQU   6
  271. TRACE    EQU   9
  272. GMAIN    EQU   10
  273. FMAIN    EQU   11
  274. ASCEBC   EQU   12
  275. EBCASC   EQU   13
  276. READKEY  EQU   200+1  MS-DOS SVC 1 READ KEY
  277. CONSOLEC EQU   200+2  MS-DOS SVC 2 DISPLAY CHAR IN R2 ON CONSOLE
  278. PRINTC   EQU   200+5  MS-DOS SVC 5 PRINT CHAR IN R2 ON STD. PRINTER
  279. WTO      EQU   200+9  MS-DOS SVC 9 PRINT STRING WITH ENDING $ ON CON.
  280. *
  281. * DATA AREAS
  282. *
  283. RESET    DC    AL1(FALSE) SWITCH TO RELOCATE CODE ONLY ONCE
  284. TRUE     EQU   1
  285. FALSE    EQU   0
  286. TBUFF    EQU   X'80'  BUFFER FOR DIRECTORY SEARCH
  287. ASYNERR  DC    V(SYNERROR)  SYNAD ERROR MESSAGE ROUTINE
  288. RECORD   DS    XL256   LOGICAL RECORD AREA
  289. ASCLF    EQU   X'0A'   ASCII LINE FEED
  290. ASCCR    EQU   X'0D'   ASCII CARRIAGE RETURN
  291. ASCASK   EQU   X'2A'   ASCII ASTERISK FOR ALC COMMENT CHECK
  292. ASCBLK   EQU   X'20'   ASCII SPACE
  293. ASCQ     EQU   X'27'   ASCII QUOTE
  294. ASCTAB   EQU   X'09'   ASCII TAB
  295. ASCFF    EQU   X'0C'   ASCII FORM FEED
  296. ASCP     EQU   X'50'   UPPERCASE ASCII P
  297. ASCPL    EQU   X'70'   LOWER CASE ASCII P
  298. OPTION   DC    X'00'
  299. ASCTITLE DC    C'TITLE'
  300. ASCEJECT DC    C'EJECT'
  301. ASCSPACE DC    C'SPACE'
  302. PAGE     DC    PL2'0'
  303. LINE     DC    PL2'50'
  304. MAXLINE  DC    PL2'50'
  305. MASK     DC    X'40202020'  EDIT MASK FOR PL2
  306. HEADING  EQU   *
  307. HEADCC   DC    AL1(ASCBLK)
  308. TITLEMSG DC    0CL65' ',65AL1(ASCBLK),2AL1(ASCBLK)
  309. PAGEMSG  DC    0CL8' ',9AL1(ASCBLK)
  310. SPACEMSG DC    AL1(ASCCR,ASCLF)     END OF HEADING
  311. WORK     DC    0CL20' '
  312. PAGEWORK DC    0CL8' ',C'PAGE'
  313. DPAGE    DC    CL4' ZZZ'
  314. DSNUT1   DC    CL64' '
  315.     COPY  CPY\IHADCB
  316. TESTCIO  CSECT
  317. SYSUT1   DC    0F'0',C'ADCB'
  318.     DC    A(DSNUT1)           PATH/FILE NAME IN PARM
  319.     DC    X'FFFF'
  320.     DC    X'00'
  321.     DC    C'SGT'               SEQ. GET TEXT
  322.     DC    X'0A1A'
  323.     DC    H'255'               LRECL
  324.     DC    H'8192'              BLKSZ
  325.     DC    A(EOFRTN)            EODAD
  326.     DC    A(SYNRTN)            SYNAD
  327.     DC    A(RECORD)            RECORD AREA
  328.     DC    XL(SYSUT1+LDCB-*)'00'
  329.     END   TESTCIO
  330.